PC Pro 1997 December/PC Pro December 1997 CD-Rom coverdisc.iso/code/IDEPeek.pas

Pascal/Delphi Source File | 1997-09-08 | 6.8 KB | 238 lines

unit IDEPeek;

interface

uses Windows, SysUtils, Classes, Forms, Menus, Dialogs, ComCtrls,
     ExtCtrls;

type
    TIDE = class (TObject)
    private
        fd: Integer;
        FieldList: TStringList;
    public
        AppBuilder: TForm;                         { main IDE window }
        procedure WriteStr (const Str: String);
        procedure DumpClassInfo (Comp: TComponent);
        procedure DumpFieldList (Ptr: PChar);
        procedure DumpMethodList (const clsName: String; Ptr: PChar);
        function TypeFromClassList (ClassList: PChar; Index: Integer): String;
        procedure CallClickMethod (Obj: TObject; const MethodName: String);
        constructor Create;
        destructor Destroy; override;
    end;

var
    IDE: TIDE;

implementation

const
    AppBuilderInstanceSize = 1164;     { Version 3, Build 5.53 }

function GetFieldTable (Obj: TObject): Pointer; assembler;
asm
    mov     eax,[eax]                   { get class pointer }
    mov     eax,[eax].vmtFieldTable     { get field list  }
end;

function GetMethodTable (Obj: TObject): Pointer; assembler;
asm
    mov     eax,[eax]                   { get class pointer }
    mov     eax,[eax].vmtMethodTable    { get method list   }
end;

function Pad (const Str: String; Width: Integer): String;
begin
    Result := Str;
    while Length (Result) < Width do Result := Result + ' ';
end;

constructor TIDE.Create;
var
    S: String;
    Idx: Integer;
    Comp: TComponent;
begin
    Inherited Create;
    FieldList := TStringList.Create;

    fd := _lcreat ('c:\ide.pas', 0);
    if fd = -1 then
       raise Exception.Create ('Can''t create output file');

    try
        for Idx := 0 to Application.ComponentCount - 1 do
        begin
            Comp := Application.Components [Idx];
            S := Format ('    %s: %s;', [Comp.Name, Comp.ClassName]);
            if Comp is TMenuItem then S := S + ' (' + TMenuItem(Comp).Caption + ')';
            WriteStr (S);
        end;

        WriteStr ('');

        AppBuilder := Application.FindComponent ('AppBuilder') as TForm;
        if AppBuilder.InstanceSize <> AppBuilderInstanceSize then
            raise Exception.Create ('Unknown IDE version - expected Build 5.53');

        { List all the components owned by AppBuilder }
        DumpClassInfo (AppBuilder);

        for Idx := 0 to AppBuilder.ComponentCount - 1 do
        begin
            Comp := AppBuilder.Components [Idx];
            { If not already dealt with }
            if FieldList.IndexOf (Comp.Name) = -1 then
                if Comp.Name <> '' then
                    WriteStr (Format ('    %s: %s;', [Comp.Name, Comp.ClassName]));
        end;

    finally
        _lclose (fd);
    end;

    { This is an example of how to call a built-in method }
    CallClickMethod (AppBuilder, 'ViewsAlignPalette');

    { Indicate that the package is loaded }
    MessageBeep (0);
end;

procedure TIDE.CallClickMethod (Obj: TObject; const MethodName: String);
var
    pp: Pointer;
begin
    pp := Obj.MethodAddress (MethodName);
    if pp = Nil then Exit;
    asm
        push    eax
        push    edx
        push    ebx
        mov     edx,Self
        mov     eax,Obj
        mov     ebx,pp
        call    ebx
        pop     ebx
        pop     edx
        pop     eax
    end;
end;

procedure TIDE.WriteStr (const Str: String);
begin
    _lwrite (fd, @Str[1], Length (Str));
    _lwrite (fd, #13 + #10, 2);
end;

function TIDE.TypeFromClassList (ClassList: PChar; Index: Integer): String;
var
    cls: TClass;
begin
    { Validate index }
    if Index >= PWord (ClassList)^ then raise Exception.Create ('Invalid classlist index');
    Inc (ClassList, sizeof (Word));
    Inc (ClassList, sizeof (Pointer) * Index);
    Result := TObject (PInteger (ClassList)^).ClassName;
end;

procedure TIDE.DumpFieldList (Ptr: PChar);
var
    Idx: Integer;
    FieldCount: Integer;
    ClassList: Pointer;
    Offset: Integer;
    Index: Word;
    ps: ^ShortString absolute Ptr;
begin
    FieldCount := PWord (Ptr)^;
    { If no fields defined, then get out }
    if FieldCount <> 0 then begin
        { Print field count }
        WriteStr (Format ('Field count = %d', [FieldCount]));
        { Skip over the field count word }
        Inc (Ptr, sizeof (Word));
        { Stash the ClassList pointer and jump over it }
        ClassList := Pointer (PInteger (Ptr)^);
        Inc (Ptr, sizeof (Pointer));
        { Now iterate through the various fields }
        for Idx := 0 to FieldCount - 1 do
        begin
            { Stash the offset into the class }
            Offset := PInteger (Ptr)^;
            Inc (Ptr, sizeof (Integer));
            { Stash the class list type index }
            Index := PWord (Ptr)^;
            Inc (Ptr, sizeof (Word));
            FieldList.Add (ps^);
            WriteStr (Pad (ps^ + ': ' + TypeFromClassList (ClassList, Index) + ';', 60) + Format ('{ $%s }', [IntToHex (Offset, 8)]));
            Inc (Ptr, Length (ps^) + 1);
        end;
    end;
end;

procedure TIDE.DumpMethodList (const clsName: String; Ptr: PChar);
var
    Idx: Integer;
    MethodCount: Integer;
    ProcAddress: Integer;
    ps: ^ShortString absolute Ptr;
begin
    MethodCount := PWord (Ptr)^;
    { If no methods defined, then get out }
    if MethodCount <> 0 then begin
        { Print method count }
        WriteStr (Format ('Method count = %d', [MethodCount]));
        { Skip over the method count word }
        Inc (Ptr, sizeof (Word));
        { Now iterate through the various fields }
        for Idx := 0 to MethodCount - 1 do
        begin
            { Skip entry size info }
            Inc (Ptr, sizeof (Word));
            ProcAddress := PInteger (Ptr)^;
            Inc (Ptr, sizeof (Integer));
            WriteStr (Format ('%s.%s @ $%s', [clsName, ps^, IntToHex (ProcAddress, 8)]));
            Inc (Ptr, Length (ps^) + 1);
        end;
    end;
end;

procedure TIDE.DumpClassInfo (Comp: TComponent);
var
    ClassPtr: PByte;
    clsName: String;
    ps: ^ShortString absolute ClassPtr;
    cls: ^TClass absolute ClassPtr;
begin
    ClassPtr := Comp.ClassInfo;
    if ClassPtr^ <> 7 then raise Exception.Create ('Invalid class ptr');
    WriteStr (Format ('%s = class (%s)', [Comp.ClassName, Comp.ClassParent.ClassName]));

    Inc (ClassPtr);  WriteStr ('');
    clsName := ps^;
    WriteStr (Format ('Class Information for "%s"', [clsName]));
    Inc (ClassPtr, Length (clsName) + 11);
    WriteStr (Format ('Source File = "%s.Pas"', [ps^]));

    DumpFieldList (GetFieldTable (Comp));
    DumpMethodList (clsName, GetMethodTable (Comp));
end;

destructor TIDE.Destroy;
begin
    FieldList.Free;
    Inherited Destroy;
end;

initialization
    IDE := TIDE.Create;
finalization
    IDE.Free;
end.